BCI NET 2/BCI NET 2.iso/archives/programming/languages/obrn-a_1.5_lib.lha/oberon-a/source2.lha/Source/Library/Files.mod

Text File | 1995-01-26 | 16.1 KB | 716 lines

(*************************************************************************

     $RCSfile: Files.mod $
  Description: Operations on files and the file directory.

   Created by: fjc (Frank Copeland)
    $Revision: 1.11 $
      $Author: fjc $
        $Date: 1995/01/26 00:40:27 $

  Copyright © 1994-1995, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

*************************************************************************)

<* STANDARD- *> <* MAIN- *>
<*$ LongVars+ *> <*$ NilChk- *> <*$ IndexChk- *>

MODULE Files;

IMPORT
  SYS := SYSTEM, Kernel, e := Exec, d := Dos, du := DosUtil,
  str := Strings, conv := Conversions, o := Oberon;

CONST
  SectorSize = 1024;
  MaxBufs = 4;

TYPE

  File *= POINTER TO Handle;

  Buffer = POINTER TO BufferRecord;

  Rider *= RECORD
    eof -: BOOLEAN;
    res -: LONGINT;
    file : File;
    pos : LONGINT;
    buf : Buffer;
    bpos : INTEGER;
  END; (* Rider *)

  Handle = RECORD
    fl -: d.FileLockPtr;
    fh -: d.FileHandlePtr;
    name : ARRAY 256 OF CHAR;
    tempNo : LONGINT;
    pos, len : LONGINT;
    useCount, nofbufs : INTEGER;
    next : File;
    firstbuf : Buffer;
  END; (* Handle *)

  DataSector = ARRAY SectorSize OF SYS.BYTE;

  BufferRecord = RECORD
    apos : LONGINT;
    lim : INTEGER;
    mod : BOOLEAN;
    next : Buffer;
    data : DataSector;
  END; (* BufferRecord *)


VAR
  root : File;
  tempNo : LONGINT;

CONST
  tempExt = ".tmp";
  bkpExt = ".bkp";


PROCEDURE GetTempNo;

  VAR time, date : LONGINT;

BEGIN (* GetTempNo *)
  o.GetClock (time, date);
  tempNo := ABS ((date * 10000H + time) DIV 2)
END GetTempNo;


PROCEDURE MakeName
  ( name : ARRAY OF CHAR;
    tempNo : LONGINT;
    ext : ARRAY OF CHAR;
    VAR tempName : ARRAY OF CHAR );

  VAR pathPart : e.LSTRPTR; s : ARRAY 13 OF CHAR;

<*$CopyArrays-*>
BEGIN (* MakeName *)
  COPY (name, tempName);
  IF tempName # "" THEN
    pathPart := d.PathPart (tempName); pathPart [0] := 0X
  END;
  ASSERT (conv.IntToStr (tempNo, 16, 0, "0", s));
  str.Append (ext, s);
  ASSERT (d.AddPart (tempName, s, LEN (tempName)))
END MakeName;


PROCEDURE Search ( fl : d.FileLockPtr ) : File;

  VAR f : File;

BEGIN (* Search *)
  f := root;
  WHILE (f # NIL) & (d.SameLock (fl, f.fl) # d.same) DO f := f.next END;
  RETURN f
END Search;


PROCEDURE Unlink (f : File);

  VAR f0 : File;

BEGIN (* Unlink *)
  IF root # NIL THEN
    IF f = root THEN
      root := root.next
    ELSE
      f0 := root;
      WHILE (f0.next # NIL) & (f0.next # f) DO
        f0 := f0.next
      END;
      IF f0.next = f THEN f0.next := f.next END;
    END
  END;
  f.next := NIL
END Unlink;


PROCEDURE ReadBuf (f : File; buf : Buffer; pos : LONGINT);

  VAR res : LONGINT;

BEGIN (* ReadBuf *)
  res := d.Seek (f.fh, pos, d.beginning);
  IF res # -1 THEN
    buf.lim := SHORT (d.Read (f^.fh, buf.data, SectorSize));
    buf.apos := pos;
    buf.mod := FALSE;
  END
END ReadBuf;


PROCEDURE WriteBuf (f : File; buf : Buffer);

  VAR res : LONGINT;

BEGIN (* WriteBuf *)
  (* ASSERT (buf # NIL, 137); *)
  res := d.Seek (f.fh, buf.apos, d.beginning);
  IF res # -1 THEN
    res := d.Write (f.fh, buf.data, buf.lim);
    IF res = buf.lim THEN
      buf.mod := FALSE;
    END
  END
END WriteBuf;


PROCEDURE GetBuf (f : File; pos : LONGINT) : Buffer;

  VAR buf, last, next : Buffer;

BEGIN (* GetBuf *)
  buf := f.firstbuf;
  LOOP
    IF buf.apos = pos THEN EXIT END;
    IF buf.next = f.firstbuf THEN
      last := buf;
      IF f.nofbufs < MaxBufs THEN (* allocate new buffer *)
        NEW (buf); INC (f.nofbufs);
      ELSE (* take one of the buffers (assuming more than one) *)
        buf := f.firstbuf; f.firstbuf := buf.next; last.next := buf.next;
        IF buf.mod THEN WriteBuf (f, buf) END
      END;
      IF pos < f.firstbuf.apos THEN
        f.firstbuf := buf
      ELSIF pos < last.apos THEN
        WHILE last.next.apos < pos DO last := last.next END;
      END;
      buf.next := last.next; last.next := buf;
      buf.apos := pos; buf.lim := 0; buf.mod := FALSE;
      IF pos < f.len THEN ReadBuf (f, buf, pos) END;
      EXIT
    END;
    buf := buf.next
  END; (* LOOP *)
  RETURN buf;
END GetBuf;


PROCEDURE Unbuffer (f : File);

  VAR buf : Buffer;

BEGIN (* Unbuffer *)
  buf := f.firstbuf;
  REPEAT
    IF buf.mod THEN WriteBuf (f, buf) END;
    buf := buf.next
  UNTIL buf = f.firstbuf
END Unbuffer;


PROCEDURE Delete * ( name : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Delete *)
  IF d.DeleteFile (name) THEN
    res := 0
  ELSE
    res := SHORT (d.IoErr ());
    IF res = d.objectNotFound THEN res := 0 END
  END
END Delete;


PROCEDURE Rename * ( old, new : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Rename *)
  IF d.Rename (old, new) THEN res := 0
  ELSE res := SHORT (d.IoErr ())
  END
END Rename;


PROCEDURE Old * ( name : ARRAY OF CHAR ) : File;

  VAR
    f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
    fib : d.FileInfoBlockPtr; len : LONGINT; buf : Buffer;

<*$CopyArrays-*>
BEGIN (* Old *)
  fl := d.Lock (name, d.sharedLock);
  IF fl # NIL THEN
    f := Search (fl);
    IF f = NIL THEN
      fh := d.Open (name, d.oldFile);
      IF fh # NIL THEN
        fib := d.AllocDosObjectTags (d.fib, NIL);
        IF fib # NIL THEN
          IF d.Examine (fl, fib^) THEN len := fib.size;
          ELSE len := 0
          END;
          d.FreeDosObject (d.fib, fib);
          NEW (f);
          IF f # NIL THEN
            NEW (buf);
            IF buf # NIL THEN
              buf.apos := 0; buf.next := buf; buf.mod := FALSE;
              IF len > SectorSize THEN buf.lim := SectorSize
              ELSE buf.lim := SHORT (len)
              END;
              f.len := len; f.firstbuf := buf; f.nofbufs := 1;
              COPY (name, f.name); f.tempNo := 0;
              f.fl := fl; f.fh := fh; f.pos := 0;
              f.useCount := 0; f.next := root; root := f;
              ReadBuf (f, buf, 0);
              RETURN f
            END;
          END;
        END;
      END;
      d.OldClose (fh)
    END;
    d.UnLock (fl)
  END;
  RETURN f
END Old;


PROCEDURE New * ( name : ARRAY OF CHAR ) : File;

  VAR
    f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
    buf : Buffer; tempName : ARRAY 256 OF CHAR;

<*$CopyArrays-*>
BEGIN (* New *)
  REPEAT
    IF tempNo < MAX (LONGINT) THEN INC (tempNo) ELSE tempNo := 1 END;
    MakeName (name, tempNo, tempExt, tempName)
  UNTIL ~du.FileExists (tempName);
  fh := d.Open (tempName, d.newFile);
  IF fh # NIL THEN
    NEW (f);
    IF f # NIL THEN
      NEW (buf);
      IF buf # NIL THEN
        buf.apos := 0; buf.next := buf; buf.mod := TRUE;
        buf.lim := 0;
        f.len := 0; f.firstbuf := buf; f.nofbufs := 1;
        COPY (name, f.name); f.tempNo := tempNo;
        f.fl := d.Lock (tempName, d.sharedLock); f.fh := fh; f.pos := 0;
        f.useCount := 0; f.next := root; root := f;
        ReadBuf (f, buf, 0);
        RETURN f
      END
    END
  END;
  d.OldClose (fh);
  RETURN f
END New;


PROCEDURE Register * ( f : File );

  VAR tempName, bkpName : ARRAY 256 OF CHAR; res : INTEGER;

BEGIN (* Register *)
  ASSERT (f # NIL, 137);
  IF f.fh # NIL THEN
    Unbuffer (f);
    (* IF f.useCount <= 0 THEN *)
      Unlink (f);
      IF d.Close (f.fh) THEN
        f.fh := NIL; d.UnLock (f.fl); f.fl := NIL;
        IF f.tempNo # 0 THEN
          MakeName (f.name, f.tempNo, tempExt, tempName);
          IF f.name = "" THEN
            Delete (tempName, res)
          ELSE
            MakeName (f.name, f.tempNo, bkpExt, bkpName);
            Rename (f.name, bkpName, res);
            IF res = 0 THEN
              Rename (tempName, f.name, res);
              IF res = 0 THEN Delete (bkpName, res) END
            ELSIF res = d.objectNotFound THEN
              Rename (tempName, f.name, res)
            END
          END
        END
      END
    (* END *)
  END
END Register;


PROCEDURE Close * ( f : File );
BEGIN (* Close *)
  ASSERT (f # NIL, 137);
  IF f.fh # NIL THEN
    Unbuffer (f);
    (* IF f.useCount <= 0 THEN *)
      Unlink (f);
      IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END
    (* END *)
  END
END Close;


PROCEDURE Purge * ( f : File );

  VAR tempName : ARRAY 256 OF CHAR; res : INTEGER;

BEGIN (* Purge *)
  ASSERT (f # NIL, 137);
  IF f.fh # NIL THEN
    Unbuffer (f);
    IF d.SetFileSize (f.fh, 0, d.beginning) = 0 THEN f.pos := 0 END;
    (* IF f.useCount <= 0 THEN *)
      Unlink (f);
      IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END;
      IF f.tempNo # 0 THEN
        MakeName (f.name, f.tempNo, tempExt, tempName);
        Delete (tempName, res)
      END
    (* END *)
  END
END Purge;


PROCEDURE Length * ( f : File ) : LONGINT;

BEGIN (* Length *)
  ASSERT (f # NIL, 137); ASSERT (f.fh # NIL, 137);
  RETURN f.len
END Length;


PROCEDURE GetDate * ( f : File; VAR time, day : LONGINT );

  VAR fib : d.FileInfoBlockPtr;

BEGIN (* GetDate *)
  ASSERT (f # NIL, 137); ASSERT (f.fh # NIL, 137);
  fib := d.AllocDosObjectTags (d.fib, NIL);
  IF fib # NIL THEN
    IF d.ExamineFH (f.fh, fib^) THEN
      o.ADOS2OberonTime (fib.date, time, day);
    END;
    d.FreeDosObject (d.fib, fib)
  END
END GetDate;


PROCEDURE Set * ( VAR r : Rider; f : File; pos : LONGINT );

BEGIN (* Set *)
  (* IF (r.file # NIL) & (r.file # f) THEN DEC (r.file.useCount) END; *)
  (* IF (f # NIL) & (f # r.file) THEN INC (f. useCount) END; *)
  r.eof := FALSE; r.res := 0; r.file := f;
  IF f # NIL THEN
    IF pos < 0 THEN r.pos := 0; r.bpos := 0
    ELSE r.bpos := SHORT (pos MOD SectorSize); r.pos := pos - r.bpos
    END;
    r.buf := f.firstbuf
  END
END Set;


PROCEDURE Pos * ( VAR r : Rider ) : LONGINT;
BEGIN (* Pos *)
  RETURN r.pos + r.bpos
END Pos;


PROCEDURE Base * ( VAR r : Rider ) : File;
BEGIN (* Base *)
  RETURN r.file
END Base;


PROCEDURE Read * ( VAR r : Rider; VAR x : SYS.BYTE );

  VAR buf : Buffer;

BEGIN (* Read *)
  ASSERT (r.file # NIL, 97);
  IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
  IF r.bpos < r.buf.lim THEN
    x := r.buf.data [r.bpos]; INC (r.bpos)
  ELSIF (r.pos + SectorSize) < r.file.len THEN
    INC (r.pos, SectorSize);
    r.buf := GetBuf (r.file, r.pos);
    x := r.buf.data [0]; r.bpos := 1
  ELSE
    x := 0X; r.eof := TRUE
  END
END Read;


PROCEDURE ReadBytes * ( VAR r : Rider; VAR x : ARRAY OF SYS.BYTE;
                          n : LONGINT );

  VAR src, dst, m : LONGINT;
      buf : Buffer;

BEGIN (* ReadBytes *)
  ASSERT (r.file # NIL, 137); ASSERT (r.file.fh # NIL, 137);
  dst := SYS.VAL (LONGINT, SYS.ADR (x));
  IF LEN (x) < n THEN HALT (25) END;
  IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
  LOOP
    IF n <= 0 THEN EXIT END;
    src := SYS.VAL (LONGINT, SYS.ADR(r.buf.data));
    INC (src, r.bpos); m := r.bpos + n;
    IF m <= r.buf.lim THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m); r.res := 0;
      EXIT
    ELSIF r.buf.lim = SectorSize THEN
      m := r.buf.lim - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); INC (dst, m); DEC (n, m)
      END;
      IF r.pos < r.file.len THEN
        INC (r.pos, SectorSize);
        r.bpos := 0; r.buf := GetBuf (r.file, r.pos);
      ELSE
        r.res := n; r.eof := TRUE; EXIT
      END;
    ELSE
      m := r.buf.lim - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); r.bpos := r.buf.lim
      END;
      r.res := n - m; r.eof := TRUE; EXIT
    END;
  END; (* LOOP *)
END ReadBytes;


<*$ < StackChk- IndexChk- *>

PROCEDURE SwapWord ( VAR w : ARRAY OF SYS.BYTE );

  VAR t : SYS.BYTE;

BEGIN (* SwapWord *)
  t := w [0]; w [0] := w [1]; w [1] := t
END SwapWord;


PROCEDURE SwapLongword ( VAR l : ARRAY OF SYS.BYTE );

  VAR t : SYS.BYTE;

BEGIN (* SwapLongword *)
  t := l [0]; l [0] := l [3]; l [3] := t;
  t := l [1]; l [1] := l [2]; l [2] := t;
END SwapLongword;

<*$ > *>


PROCEDURE ReadInt * ( VAR r : Rider; VAR x : INTEGER );

  VAR i : INTEGER;

BEGIN (* ReadInt *)
  ReadBytes (r, i, 2); SwapWord (i); x := i
END ReadInt;


PROCEDURE ReadLInt * ( VAR r : Rider; VAR x : LONGINT );

  VAR i : LONGINT;

BEGIN (* ReadLInt *)
  ReadBytes (r, i, 4); SwapLongword (i); x := i
END ReadLInt;


PROCEDURE ReadReal * ( VAR r : Rider; VAR x : REAL );

  VAR y : REAL;

BEGIN (* ReadReal *)
  ReadBytes (r, y, 4); SwapLongword (y); x := y
END ReadReal;


PROCEDURE ReadLReal * ( VAR r : Rider; VAR x : LONGREAL );
BEGIN (* ReadLReal *)
  HALT (99)
END ReadLReal;


PROCEDURE ReadNum * ( VAR r : Rider; VAR x : LONGINT );

  VAR s : SHORTINT; ch : CHAR; n : LONGINT;

BEGIN (* ReadNum *)
  s := 0; n := 0; Read(r, ch);
  WHILE ORD(ch) >= 128 DO
    INC(n, ASH(ORD(ch) - 128, s)); INC(s, 7); Read(r, ch)
  END;
  x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
END ReadNum;


PROCEDURE ReadString * ( VAR r : Rider; VAR x : ARRAY OF CHAR );

  VAR ch : CHAR; i : INTEGER;

BEGIN (* ReadString *)
  i := 0;
  REPEAT
    Read (r, ch); x [i] := ch; INC (i)
  UNTIL ch = 0X
END ReadString;


PROCEDURE ReadSet * ( VAR r : Rider; VAR x : SET );

  VAR s : SET;

BEGIN (* ReadSet *)
  ReadBytes (r, s, 4); SwapLongword (s); x := s
END ReadSet;


PROCEDURE ReadBool * ( VAR r : Rider; VAR x : BOOLEAN );

  VAR i : SHORTINT;

BEGIN (* ReadBool *)
  Read (r, i); x := (i # 0)
END ReadBool;


PROCEDURE Write * ( VAR r : Rider; x : SYS.BYTE );

  VAR f : File; buf : Buffer;

BEGIN (* Write *)
  ASSERT (r.file # NIL, 137); ASSERT (r.file.fh # NIL, 137);
  IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
  IF r.bpos >= r.buf.lim THEN
    IF r.bpos < SectorSize THEN
      INC (r.buf.lim); INC (r.file.len)
    ELSE
      f := r.file; INC (r.pos, SectorSize);
      r.buf := GetBuf (f, r.pos);
      IF r.pos >= f.len THEN r.buf.lim := 1; f.len := r.pos END;
      r.bpos := 0
    END
  END;
  r.buf.data [r.bpos] := x; INC (r.bpos); r.buf.mod := TRUE
END Write;


PROCEDURE WriteBytes * ( VAR r : Rider; VAR x : ARRAY OF SYS.BYTE;
                          n : LONGINT );

  VAR src, dst, m : LONGINT; f : File; buf : Buffer;

BEGIN (* WriteBytes *)
  ASSERT (r.file # NIL, 137); ASSERT (r.file.fh # NIL, 137);
  src := SYS.VAL (LONGINT, SYS.ADR (x));
  IF LEN (x) < n THEN HALT (25) END;
  IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
  LOOP
    IF n <= 0 THEN EXIT END;
    r.buf.mod := TRUE;
    dst := SYS.VAL (LONGINT, SYS.ADR(r.buf.data)); INC (dst, r.bpos);
    m := r.bpos + n;
    IF m <= r.buf.lim THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m); EXIT
    ELSIF m <= SectorSize THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m);
      INC (r.file.len, n); r.buf.lim := SHORT (m); EXIT
    ELSE
      m := SectorSize - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); INC (src, m); DEC (n, m);
        INC (r.buf.lim, SHORT (m))
      END;
      f := r.file; INC (r.pos, SectorSize);
      r.bpos := 0; r.buf := GetBuf (f, r.pos);
      IF r.pos >= f.len THEN r.buf.lim := 0; f.len := r.pos END;
    END;
  END; (* LOOP *)
END WriteBytes;


PROCEDURE WriteInt * ( VAR r : Rider; x : INTEGER );
BEGIN (* WriteInt *)
  SwapWord (x); WriteBytes (r, x, 2);
END WriteInt;


PROCEDURE WriteLInt * ( VAR r : Rider; x : LONGINT );
BEGIN (* WriteLInt *)
  SwapLongword (x); WriteBytes (r, x, 4);
END WriteLInt;


PROCEDURE WriteReal * ( VAR r : Rider; x : REAL );
BEGIN (* WriteReal *)
  SwapLongword (x); WriteBytes (r, x, 4);
END WriteReal;


PROCEDURE WriteLReal * ( VAR r : Rider; x : LONGREAL );
BEGIN (* WriteLReal *)
  HALT (99)
END WriteLReal;


PROCEDURE WriteNum * ( VAR r : Rider; x : LONGINT );
BEGIN (* WriteNum *)
  WHILE (x < -64) OR (x > 63) DO
    Write(r, CHR(x MOD 128 + 128)); x := x DIV 128
  END;
  Write(r, CHR(x MOD 128))
END WriteNum;


PROCEDURE WriteString * ( VAR r : Rider; x : ARRAY OF CHAR );
<*$CopyArrays-*>
BEGIN (* WriteString *)
  WriteBytes (r, x, str.Length (x)); Write (r, 0X)
END WriteString;


PROCEDURE WriteSet * ( VAR r : Rider; x : SET );
BEGIN (* WriteSet *)
  SwapLongword (x); WriteBytes (r, x, 4);
END WriteSet;


PROCEDURE WriteBool * ( VAR r : Rider; x : BOOLEAN );

  VAR i : SHORTINT;

BEGIN (* WriteBool *)
  IF x THEN i := 1 ELSE i := 0 END; Write (r, i)
END WriteBool;


PROCEDURE* CloseFiles ( VAR rc : LONGINT );

BEGIN (* CloseFiles *)
  WHILE root # NIL DO
    IF root.fh # NIL THEN
      Unbuffer (root);
      IF d.Close (root.fh) THEN END;
      d.UnLock (root.fl);
    END;
    root := root.next
  END;
END CloseFiles;


BEGIN (* Files *)
  root := NIL; GetTempNo; Kernel.SetCleanup (CloseFiles);
END Files.